library(EDAWR)
library(dplyr)
library(tidyverse)
library(readxl)
library(ggplot2)
library(plotly)
library(reactable)
library(caret)
library(randomForest)
set.seed(23)
dirty_wdi = read_excel("Data/World_Development_Indicators.xlsx", na="..")
Zbiór zawierał komórki o wartościach ‘..’ nie zawierające danych. Zostały one zastąpione wartościami pustymi na etapie wczytywania.
Wyodrębnienie wszystkich serii
series_df <- dirty_wdi %>%
distinct(`Series Name`, `Series Code`)
series_df %>%
reactable(resizable=TRUE, wrap=FALSE, bordered=TRUE)
Utworzenie tabeli zawierającej tylko kraje i ich wskaźniki rozwoju na przestrzeni lat
country_df <- dirty_wdi %>%
gather("Year", "Value", 5:ncol(dirty_wdi)) %>%
select(-c(`Series Code`)) %>%
filter(!`Country Name` %in% c("Low & middle income","Low income","Lower middle income","Middle income","Upper middle income","High income")) %>%
mutate(Year = as.numeric(substr(Year, 1, 4)))
country_df %>%
head() %>%
reactable(resizable=TRUE, wrap=FALSE, bordered=TRUE)
Dla uproszczenia dalszej analizy, odfiltrowano dane tylko do Niemiec, o rozsądnym współczynnik wypełnienia 65%. Wybrano Niemcy, ponieważ posiadają największy % udziału w PKB Unii Europejskiej.
germany_df <- country_df %>%
filter(`Country Name` == 'Germany') %>%
select(-c(`Country Name`,`Country Code`))
germany_df %>%
head() %>%
reactable(resizable=TRUE, wrap=FALSE, bordered=TRUE)
Utworzenie zbioru danych zawierającego wszystkie wskaźniki dla różnych kategorii zamożności, które zostaną wykorzystane w podsumowaniu
group_df <- dirty_wdi %>%
gather("Year", "Value", 5:ncol(dirty_wdi), na.rm = TRUE) %>%
select(-`Series Name`) %>%
filter(`Country Name` %in% c("Low & middle income","Low income","Lower middle income","Middle income","Upper middle income","High income")) %>%
mutate(Year = as.numeric(substr(Year, 1, 4)))
group_df %>%
head() %>%
reactable(resizable=TRUE, wrap=FALSE, bordered=TRUE)
Cały zbiór World Development Indicators zawiera dane o 214 wskaźnikach rozwoju 201 państw od roku 1970 do roku 2020. Oprócz tego zawiera informacje o kategoriach zamożności, których trendy zostały przedstawione poniżej:
group_df %>%
filter(`Series Code` == "NY.GDP.PCAP.CD") %>%
ggplot(aes(x=Year, y=Value)) +
geom_point() +
geom_smooth(method = "lm") +
facet_wrap( ~ `Country Name`) +
labs(x="Rok", y="Wartość [USD]") +
ggtitle('PKB na mieszkańca') +
theme_minimal()
Na podstawie wykresów możemy stwierdzić że wśród krajów niemal każdej z grup widoczna jest tendencja wzrostowa ilości Przychodu Krajowego Brutto na mieszkańca, na przestrzeni danych lat.
Zbiór zawiera informacje o wartości złota wyrażoną w wybranych walutach. Ponieważ w poprzednim zbiorze PKB na mieszkańca był wyrażony w USD, w przypadku wczytywania tego zbioru pozostałe waluty są pomijane.
dirty_gold <- read.csv("Data/Gold prices.csv", colClasses = c("Date", "numeric", "numeric", rep("NULL", 4)), col.names = c("Date", "AM_USD", "PM_USD", rep("NULL", 4)), header = TRUE)
dirty_gold %>%
head() %>%
reactable(resizable=TRUE, wrap=FALSE, bordered=TRUE)
Niektóre rekordy posiadają puste komórki w pierwszej lub drugiej połowie dnia. Zostają zastąpione istniejącą już wartością z danego dnia. Dodatkowo zostaną wszystkie dane zostaną pogrupowane po roku oraz dla każdego roku wyliczona ich średnia.
dirty_gold <- dirty_gold %>%
mutate(AM_USD = coalesce(AM_USD,PM_USD), PM_USD = coalesce(PM_USD,AM_USD))
gold_df <- dirty_gold %>%
mutate(Year = as.numeric(substr(Date, 1, 4))) %>%
group_by(Year) %>%
summarize(USD = (mean(AM_USD) + mean(PM_USD)) / 2)
gold_df %>%
head() %>%
reactable(resizable=TRUE, wrap=FALSE, bordered=TRUE)
Zbiór zawiera informacje o średniej cenie złota na przestrzeni lat 1968-2021 wyrażonej w USD
gold_df %>%
ggplot(aes(x=Year, y=USD)) +
geom_line() +
geom_point() +
geom_smooth(method = "lm") +
ylim(0, NA) +
labs(x="Rok", y="Wartość złota [USD]") +
ggtitle("Wartość złota na przestrzeni lat") +
theme_minimal()
Na podstawie powyższego wykresu możemy łatwo stwierdzić że złoto znacznie zwiększyła swoją wartość w USD na przestrzeni lat.
currency_df <- read.csv("Data/CurrencyExchangeRates.csv", colClasses = c("Date", rep("numeric", 51)), header = TRUE, na="")
currency_df %>%
head() %>%
reactable(resizable=TRUE, wrap=FALSE, bordered=TRUE)
Zbiór przedstawia codzienny kurs wymiany 51 walut. Na potrzeby analizy zostaną ograniczone do Chińskich Yuanów, Funtów Brytyjskich, Euro oraz Franków Szwajcarskich. Ponieważ dane są codzienne kursy wymiany walut, zostaną wyliczone średnie dla każdego roku.
currency_df <- currency_df %>%
select(Date, Chinese.Yuan, U.K..Pound.Sterling, Euro, Swiss.Franc) %>%
rename(UK.Pound = U.K..Pound.Sterling) %>%
mutate(Year = as.numeric(format(Date, "%Y"))) %>%
group_by(Year) %>%
summarise(Chinese.Yuan = mean(Chinese.Yuan, na.rm = TRUE),
UK.Pound = mean(UK.Pound, na.rm=TRUE),
Euro = mean(Euro, na.rm=TRUE),
Swiss.Franc = mean(Swiss.Franc, na.rm=TRUE))
currency_df %>%
rename(Yuan = Chinese.Yuan, Funt = UK.Pound, Frank = Swiss.Franc) %>%
gather(Currency, Value, Yuan:Frank) %>%
ggplot(aes(x=Year, y=Value)) +
geom_point() +
facet_wrap( ~ Currency) +
labs(x="Rok", y="Kurs na USD") +
ggtitle('Kursy wybranych walut na przestrzeni lat') +
theme_minimal() +
theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1))
Na podstawie wykresów możemy zauważyć znaczącą zmianę jedynie w przypadku Chińskich Yuanów. Kurs pozostałych walut na USD pozostaje na podobnym poziomie
Zbiór zawiera informacje o indeksie S&P (Standard and Poor), czyli powszechne akcje na giełdzie mierzące ogólne wyniki rynku.
sp_composite_df <- read.csv("Data/S&P Composite.csv", colClasses = c("Date", rep("numeric", 9)), header = TRUE, na="")
sp_composite_df %>%
head() %>%
reactable(resizable=TRUE, wrap=FALSE, bordered=TRUE)
Podobnie do zbioru kursów walut, w tym przypadku dane również zostaną pogrupowane po roku oraz zostanie wyliczona ich średnia. Dodatkowo do dalszej analizy odfiltrowane zostają dane sprzed 1995 roku.
sp_composite_df <- sp_composite_df %>%
mutate(Year = as.numeric(format(Year, format="%Y"))) %>%
group_by(Year) %>%
filter(Year >= 1995) %>%
summarise(S.P.Composite = mean(S.P.Composite))
sp_composite_df %>%
head() %>%
reactable(resizable=TRUE, wrap=FALSE, bordered=TRUE)
Złączenie uzyskanych zbiorów w jeden
germany_df <- germany_df %>%
spread(`Series Name`, `Value`)
temp_df <- inner_join(germany_df, gold_df) %>%
rename(GoldUSD = USD)
temp_df <- inner_join(temp_df, currency_df)
sum_df <- inner_join(temp_df, sp_composite_df)
sum_df %>%
head() %>%
reactable(resizable=TRUE, wrap=FALSE, bordered=TRUE)
Zbiorowa korelacja wszystkich atrybutów
cor_mat <- cor(
x = select(sum_df, -1),
use="pairwise.complete.obs")
cor_df = data.frame(cor_mat) %>%
rownames_to_column()
cor_df <- cor_df %>%
pivot_longer(-rowname, names_to="colname")
cor_df %>%
head() %>%
reactable(resizable=TRUE, wrap=FALSE, bordered=TRUE)
cor_plot <- ggplot(cor_df, aes(colname, rowname, fill=value)) +
geom_tile() +
scale_fill_gradient2() +
theme(axis.text.x = element_blank(), axis.text.y = element_blank())
ggplotly(cor_plot)
Wyodrębnienie bardziej interesujących korelacji jest trudne w tak dużym zbiorze, dlatego ze zbioru WDI pozostaną tylko wybrane atrybuty:
Korelacja z mniejszą ilością atrybutów:
cor_mat2 <- cor(
x = select(filtered_sum_df, -1),
use="pairwise.complete.obs")
cor_df2 = data.frame(cor_mat2) %>%
rownames_to_column() %>%
pivot_longer(-rowname, names_to="colname")
cor_df2 %>%
head() %>%
reactable(resizable=TRUE, wrap=FALSE, bordered=TRUE)
cor_plot2 <- ggplot(cor_df2, aes(colname, rowname, fill=value)) +
geom_tile() +
scale_fill_gradient2() +
theme(axis.text.x = element_text(angle=90, hjust=0))
ggplotly(cor_plot2)
Największe korelacje ze współczynnikiem -0.9/0.9 lub większym:
Większość uzyskanych korelacji ma logiczne wytłumaczenie, w miarę rozwoju handlu export oraz import rosną równomiernie, a co za tym idzie społeczeństwo się bogaci, wzrasta również średnia życia. Ciekawą zależnością jest ilość użytkowników internetu do średniej długości życia w momencie urodzenia. Może to wynikać ze zwiększonej świadomości ludzi na temat opieki zdrowotnej. Całkiem odwrotny wpływ na długość życia ma emisja CO2 na mieszkańca. Kolejnym interesującym tematem jest zależność kursu walut (Chińskiego Yuana oraz Franka Szwajcarskiego) do kursu złota, PKB na mieszkańca oraz importu/exportu towarów. Jest to najpewniej spowodowane tym, że atrybuty te są wyrażone w walucie USD, a kursy walut również są zależne od USD.
Najmniejsze korelacje:
Tutaj możemy zauważyć że % populacji posiadającej dostęp do internetu niemal nie zmienia się wraz z jej wzrostem.
Wykres populacji kobiet, mężczyzn i całkowitej na świecie na przestrzeni lat
Kolejne wykresy nawiązują już tylko do zredukowanego zbioru z Niemiec. Zmiana wartości złota w stosunku do Yuana w kolejnych latach:
Zmiana procenta populacji korzystającej z internetu w stosunku do PKB na mieszkańca w kolejnych latach. Rozmiar kropki oznacza średnią długość życia:
Niestety wybrany wcześniej atrybut o wydatkach na edukację ma zbyt wiele wartości pustych, dlatego do dalszych obliczeń konieczne jest jego odrzucenie.
filtered_sum_df <- filtered_sum_df %>%
select(-`Gov.expenditure.on.education.USD`)
Pozostaje jeszcze tylko usunięcie wierszy zawierających wartości puste i usunięcie kolumny z rokiem.
filtered_sum_df <- filtered_sum_df[complete.cases(filtered_sum_df), ]
prediction_df <- filtered_sum_df %>%
select(-`Year`)
inTraining <- createDataPartition( y = prediction_df$GoldUSD, p=0.7, list=F)
training <- prediction_df[ inTraining,]
testing <- prediction_df[-inTraining,]
ctrl <- trainControl(
method = "repeatedcv",
number = 2,
repeats = 5)
fit <- train(
GoldUSD ~ .,
data = training,
method = "rf",
trControl = ctrl,
ntree = 30
)
fit
## Random Forest
##
## 17 samples
## 12 predictors
##
## No pre-processing
## Resampling: Cross-Validated (2 fold, repeated 5 times)
## Summary of sample sizes: 8, 9, 9, 8, 9, 8, ...
## Resampling results across tuning parameters:
##
## mtry RMSE Rsquared MAE
## 2 205.8369 0.8933538 172.8400
## 7 189.5922 0.8995342 161.1135
## 12 190.8767 0.9174752 155.2223
##
## RMSE was used to select the optimal model using the smallest value.
## The final value used for the model was mtry = 7.
prediction <- predict(fit, newdata=testing)
prediction
## 1 2 3 4
## 307.4017 556.3564 1442.9118 1281.8121
Udało się w zadowalający sposób zaestymować cenę złota na podstawie danych atrybutów.
gbmImp <- varImp(fit, scale = FALSE)
plot(gbmImp)
Co zaskakujące okazuje się, że najważniejszym atrybutem jest średnia długość życia w momencie narodzin. Niemal o połowę mniejszą ważność ma procent ludności używający internetu, a dopiero kolejnymi czynnikami są handel, emisja CO2, Yuan czy też PKB na mieszkańca.